home *** CD-ROM | disk | FTP | other *** search
/ Software Vault: The Gold Collection / Software Vault - The Gold Collection (American Databankers) (1993).ISO / cdr01 / halcn305.zip / GSDMOTV2.PAS < prev    next >
Pascal/Delphi Source File  |  1993-02-07  |  12KB  |  433 lines
  1. program GSDMOTV2;
  2. {------------------------------------------------------------------------------
  3.                               DBase File Display
  4.                              TurboVision Sample 2
  5.  
  6.        Copyright (c)  Richard F. Griffin
  7.  
  8.        28 January 1993
  9.  
  10.        102 Molded Stone Pl
  11.        Warner Robins, GA  31088
  12.  
  13.        -------------------------------------------------------------
  14.        This program demonstrates that the basic Griffin Solutions
  15.        routines will work in a TurboVision environment.
  16.  
  17.        This demo provides a file viewer using TurboVision methods.
  18.        One unit, GSV_FLDS.PAS is also used for improved inputline
  19.        support.
  20.  
  21.        Memory is at a premium in the IDE using TurboVision.  If you
  22.        get heap overflow errors or 'strange' things happen, if probably
  23.        means there is not enough memory to run in the IDE.  To regain
  24.        memory, you can compile to disk instead of memory.  Use the
  25.        MemAvail value in the Watch window to see how much memory is
  26.        available.
  27.  
  28. -------------------------------------------------------------------------------}
  29.  
  30. uses DOS,
  31.      Objects, Drivers, Views, Menus, Dialogs, StdDlg, App, Memory,
  32.      GSOBShel, GSV_Flds;
  33.  
  34. const
  35.   cmFileOpen        = 100;
  36.   cmVideoMode       = 101;
  37.   cmNextRec         = 102;
  38.   cmPrevRec         = 103;
  39.   cmPageUp          = 104;
  40.   cmPageDn          = 105;
  41.   hcFileOpen        = 2;
  42.   hcDataField       = 901;
  43.  
  44. type
  45.  
  46.   PdBDialog = ^TdBDialog;
  47.   TdBDialog = object(TDialog)
  48.     FldColl   : PCollection;
  49.     FldsInFile: integer;
  50.     FldsOnScrn: integer;
  51.     FirstField: integer;
  52.     FirstItem : PView;
  53.     dbCheck   : PCheckBoxes;
  54.     CBox      : word;
  55.     dbStatic  : PStaticText;
  56.     dbCancel  : PButton;
  57.     procedure HandleEvent(var Event: TEvent); virtual;
  58.     procedure ShowDialog(ClrInp : boolean);
  59.     procedure SaveDialog(C : Word; ClrInp : boolean);
  60.   end;
  61.  
  62.   TMyApp = object(TApplication)
  63.     Dialog    : PdBDialog;
  64.     procedure HandleEvent(var Event: TEvent); virtual;
  65.     procedure InitMenuBar; virtual;
  66.     procedure InitStatusLine; virtual;
  67.     procedure FileOpen;
  68.     procedure NewDialog;
  69.   end;
  70.  
  71. var
  72.   NewMode : word;
  73.   MyApp: TMyApp;
  74.  
  75.  
  76. procedure TdBDialog.HandleEvent(var Event: TEvent);
  77. var
  78.    Chg   : boolean;
  79.    Rfrsh : boolean;
  80.    MLine : TPoint;
  81.    Q,
  82.    R     : TRect;
  83.    L     : integer;
  84.    W     : word;
  85.    P     : Pointer;
  86. begin
  87.   if Event.What = evKeyDown then
  88.   begin
  89.      case Event.KeyCode of
  90.         kbPgUp,
  91.         kbPgDn     : begin
  92.                         if Event.KeyCode = kbPgUp then W := cmPageUp
  93.                            else W := cmPageDn;
  94.                         ClearEvent(Event);
  95.                         P := Message(Owner,evCommand,W,@Self);
  96.                         exit;
  97.                      end;
  98.         kbAltE     : begin end;
  99.         kbEnter    : if Current^.HelpCtx = hcDataField then
  100.                         Event.KeyCode := kbTab;
  101.         kbDown     : Event.KeyCode := kbTab;
  102.         kbUp       : Event.KeyCode := kbShiftTab;
  103.         else         begin
  104.                         TDialog.HandleEvent(Event);
  105.                         exit;
  106.                      end;
  107.      end;
  108.      if Current^.Valid(1) then TDialog.HandleEvent(Event)
  109.      else
  110.         ClearEvent(Event);
  111.      exit;
  112.   end;
  113.   if Event.What = evMouseDown then
  114.   begin
  115.      dbCancel^.GetBounds(Q);
  116.      Current^.GetBounds(R);
  117.      MakeLocal(Event.Where,MLine);
  118.      Chg := R.Contains(MLine);
  119.      if not Chg then Chg := Q.Contains(MLine);
  120.      if not Chg then Chg := (MLine.X = 3) and (Mline.Y = 0);
  121.      if Chg then TDialog.HandleEvent(Event)
  122.      else
  123.         if Current^.Valid(1) then TDialog.HandleEvent(Event)
  124.         else
  125.            ClearEvent(Event);
  126.      exit;
  127.   end;
  128.   if Event.What = evCommand then
  129.   begin
  130.     case Event.Command of
  131.       cmPageUp,
  132.       cmPageDn  : begin
  133.                        Chg := true;
  134.                        if (Current^.HelpCtx = hcDataField) then
  135.                           Chg := Current^.Valid(1);
  136.                        if Chg then
  137.                        begin
  138.                           L := FirstField;
  139.                           if Event.Command = cmPageUp then
  140.                              FirstField := FirstField-(FldsOnScrn-1)
  141.                           else
  142.                              FirstField := FirstField+(FldsOnScrn-1);
  143.                           if FirstField < 1 then FirstField := 1
  144.                              else
  145.                                 if FirstField > FldsInFile-(FldsOnScrn-1) then
  146.                                    FirstField := FldsInFile-(FldsOnScrn-1);
  147.                           if FirstField <> L then
  148.                           begin
  149.                              SaveDialog(0,true);
  150.                              ShowDialog(true);
  151.                           end;
  152.                           FirstItem^.Select;
  153.                        end;
  154.                        ClearEvent(Event);
  155.                        exit;
  156.                     end;
  157.  
  158.       cmNextRec,
  159.       cmPrevRec   : begin
  160.                        Chg := true;
  161.                        if (Current^.HelpCtx = hcDataField) then
  162.                           Chg := Current^.Valid(1);
  163.                        if Chg then
  164.                        begin
  165.                           Rfrsh := FirstField <> 1;
  166.                           FirstField := 1;
  167.                           SaveDialog(1,Rfrsh);
  168.                           if Event.Command = cmNextRec then
  169.                              Skip(1)
  170.                           else Skip(-1);
  171.                           ShowDialog(Rfrsh);
  172.                           FirstItem^.Select;
  173.                        end;
  174.                        ClearEvent(Event);
  175.                        exit;
  176.                     end;
  177.     end;
  178.   end;
  179.   TDialog.HandleEvent(Event)
  180. end;
  181.  
  182.  
  183. { TMyApp }
  184.  
  185. procedure TMyApp.HandleEvent(var Event: TEvent);
  186. begin
  187.   TApplication.HandleEvent(Event);
  188.   if Event.What = evCommand then
  189.   begin
  190.     case Event.Command of
  191.       cmFileOpen : FileOpen;
  192.       cmVideoMode:
  193.         begin
  194.           NewMode := ScreenMode xor smFont8x8;
  195.           if NewMode and smFont8x8 <> 0 then
  196.             ShadowSize.X := 1
  197.           else ShadowSize.X := 2;
  198.           SetScreenMode(NewMode);
  199.         end;
  200.     else
  201.       Exit;
  202.     end;
  203.     ClearEvent(Event);
  204.   end;
  205. end;
  206.  
  207. procedure TMyApp.InitMenuBar;
  208. var R: TRect;
  209. begin
  210.   GetExtent(R);
  211.   R.B.Y := R.A.Y + 1;
  212.   MenuBar := New(PMenuBar, Init(R, NewMenu(
  213.     NewSubMenu('~F~ile', hcNoContext, NewMenu(
  214.       NewItem('~O~pen', 'F3', kbF3, cmFileOpen, hcNoContext,
  215.       NewLine(
  216.       NewItem('~V~ideo mode','', kbNoKey, cmVideoMode, hcNoContext,
  217.       NewItem('E~x~it', 'Alt-X', kbAltX, cmQuit, hcNoContext,
  218.       nil))))),
  219.     nil)
  220.   )));
  221. end;
  222.  
  223. procedure TMyApp.InitStatusLine;
  224. var R: TRect;
  225. begin
  226.   GetExtent(R);
  227.   R.A.Y := R.B.Y - 1;
  228.   StatusLine := New(PStatusLine, Init(R,
  229.     NewStatusDef(0, $FFFF,
  230.       NewStatusKey('', kbF10, cmMenu,
  231.       NewStatusKey('~Alt-X~ Exit', kbAltX, cmQuit,
  232.       nil)),
  233.     nil)
  234.   ));
  235. end;
  236.  
  237. procedure TMyApp.FileOpen;
  238. var
  239.   Dg: PFileDialog;
  240.   FileName: PathStr;
  241.   D: DirStr;
  242.   N: NameStr;
  243.   E: ExtStr;
  244. begin
  245.   Dg := New(PFileDialog, Init('*.DBF', 'Open a File',
  246.     '~N~ame', fdOpenButton + fdHelpButton, 100));
  247.   Dg^.HelpCtx := hcFileOpen;
  248.   if ValidView(Dg) <> nil then
  249.   begin
  250.     if Desktop^.ExecView(Dg) <> cmCancel then
  251.     begin
  252.       Dg^.GetFileName(FileName);
  253.       FSplit(FExpand(FileName), D, N, E);
  254.       GSOBShel.Select(1);
  255.       Use(D+N);
  256.       NewDialog;
  257.       CloseDataBAses;
  258.     end;
  259.     Dispose(Dg, Done);
  260.   end;
  261. end;
  262.  
  263. procedure TMyApp.NewDialog;
  264. var
  265.   dBInput: PdBInputLine;
  266.   R: TRect;
  267.   C: Word;
  268.   Pgd: boolean;
  269. begin
  270.   GoTop;
  271.   GetExtent(R);
  272.   dec(R.B.Y,2);
  273.   Dialog := New(PdBDialog, Init(R, Alias));
  274.   with Dialog^ do
  275.   begin
  276.     FldColl := nil;
  277.     FirstField := 1;
  278.     FldsOnScrn := Size.Y-5;
  279.     FldsInFile := FieldCount;
  280.     Pgd := FldsOnScrn < FldsInFile;
  281.     if FldsOnScrn > FldsInFile then
  282.        FldsOnScrn := FldsInFile;
  283.     R.Assign(3, Size.Y-2, 18, Size.Y-1);
  284.     dBCheck := New(PCheckBoxes, Init(R,
  285.       NewSItem('D~e~leted',
  286.       nil)
  287.     ));
  288.     R.Assign(40, Size.Y-2, 65, Size.Y-1);
  289.     dBStatic := New(PStaticText, Init(R,'Record'));
  290.     Insert(dbStatic);
  291.     ShowDialog(true);
  292.     Insert(dbCheck);
  293.     R.Assign(68, 2, 78, 4);
  294.     Insert(New(PButton, Init(R, '~F~inish', cmOK, bfNormal)));
  295.     R.Assign(68, 5, 78, 7);
  296.     dbCancel := New(PButton, Init(R, 'Cancel', cmCancel, bfNormal));
  297.     Insert(dbCancel);
  298.     if Pgd then
  299.     begin
  300.        R.Assign(68, 8, 78, 10);
  301.        Insert(New(PButton, Init(R, 'Pg~U~p', cmPageUp, bfNormal)));
  302.        R.Assign(68, 11, 78, 13);
  303.        Insert(New(PButton, Init(R, 'Pg~D~n', cmPageDn, bfNormal)));
  304.     end;
  305.     R.Assign(68, 14, 78, 16);
  306.     Insert(New(PButton, Init(R, '~P~rev', cmPrevRec, bfNormal)));
  307.     R.Assign(68, 17, 78, 19);
  308.     Insert(New(PButton, Init(R, '~N~ext', cmNextRec, bfNormal)));
  309.     dBInput := FldColl^.At(0);
  310.     dBInput^.Select;
  311.   end;
  312.   C := DeskTop^.ExecView(Dialog);
  313.   Dialog^.SaveDialog(C,true);
  314.   Dispose(Dialog^.FldColl, Done);
  315.   Dispose(Dialog, Done);
  316. end;
  317.  
  318. procedure TdBDialog.ShowDialog(ClrInp : boolean);
  319. var
  320.   dBInput: PdBInputLine;
  321.   R: TRect;
  322.   I,
  323.   X,
  324.   Y : Integer;
  325.   S : string;
  326.   S1,S2 : string[8];
  327.   DFlg : word;
  328. begin
  329.    Y := 1;
  330.    if FldColl = nil then
  331.    begin
  332.       ClrInp := true;
  333.       New(FldColl, Init(FieldCount,4));
  334.       for i := FirstField to FldsInFile do
  335.       begin
  336.          X := FieldLen(i);
  337.          if X+27 > Size.X then X := Size.X-27;
  338.          R.Assign(13, Y, 15+X,Y+1);
  339.          case FieldType(i) of
  340.             'F',
  341.             'N'  : dBInput := New(PdBNumInputLine, Init(R, FieldLen(i)));
  342.             else   dBInput := New(PdBInputLine, Init(R, FieldLen(i)));
  343.          end;
  344.          dbInput^.HelpCtx := hcDataField;
  345.          FldColl^.Insert(dBInput);
  346.          R.Assign(1,Y,12,Y+1);
  347.          dbInput^.FldLabel := New(PLabel, Init(R, Field(i), dBInput));
  348.          inc(y);
  349.       end;
  350.    end;
  351.    Y := 1;
  352.    for i := FirstField to FldsOnScrn+FirstField-1 do
  353.    begin
  354.       S := StringGetN(i);
  355.       dBInput := FldColl^.At(i-1);
  356.       if i = FirstField then FirstItem := dBInput;
  357.       dBInput^.SetData(S);
  358.       if ClrInp then
  359.       begin
  360.          dbInput^.GetBounds(R);
  361.          R.Assign(R.A.X,Y,R.B.X,Y+1);
  362.          dbInput^.SetBounds(R);
  363.          Insert(dBInput);
  364.          dbInput^.FldLabel^.GetBounds(R);
  365.          R.Assign(R.A.X,Y,R.B.X,Y+1);
  366.          dbInput^.FldLabel^.SetBounds(R);
  367.          insert(dbInput^.FldLabel);
  368.       end;
  369.       dBInput^.IsActive := true;
  370.       inc(Y);
  371.    end;
  372.    if Deleted then CBox := 1 else CBox := 0;
  373.    dBCheck^.SetData(CBox);
  374.    if dbStatic^.Text <> nil then DisposeStr(dbStatic^.Text);
  375.    Str(RecNo,S1);
  376.    Str(RecCount,S2);
  377.    S := 'Record '+S1+' of '+S2;
  378.    dbStatic^.Text := NewStr(S);
  379.    if Current^.HelpCtx = hcDataField then
  380.       PInputLine(Current)^.SelectAll(True);
  381.    ReDraw;
  382. end;
  383.  
  384. procedure TdBDialog.SaveDialog(C : Word; ClrInp : boolean);
  385. var
  386.   dBInput: PdBInputLine;
  387.   I : integer;
  388.   Chg : boolean;
  389.   S : string;
  390.   DFlg : word;
  391. begin
  392.   Chg := false;
  393.   for i := 0 to FldColl^.Count-1 do
  394.   begin
  395.      dBInput := FldColl^.At(i);
  396.      if C <> cmCancel then
  397.      begin
  398.         if dBInput^.Changed then
  399.         begin
  400.            Chg := true;
  401.            dBInput^.GetData(S);
  402.            StringPutN(i+1,S);
  403.         end;
  404.      end;
  405.      if dBInput^.IsActive then
  406.      begin
  407.         if ClrInp then
  408.         begin
  409.            Delete(dBInput);
  410.            delete(dbInput^.FldLabel);
  411.         end;
  412.         dBInput^.IsActive := false;
  413.      end;
  414.   end;
  415.   if C <> cmCancel then
  416.   begin
  417.      dFLg := dBCheck^.Value;
  418.      if DFlg <> CBox then
  419.      begin
  420.         if DFlg = 0 then RecallRec else DeleteRec;
  421.         Chg := false;
  422.      end;
  423.   end;
  424.   if Chg then Replace;
  425. end;
  426.  
  427.  
  428. begin
  429.   MyApp.Init;
  430.   MyApp.Run;
  431.   MyApp.Done;
  432. end.
  433.